#lang racket

(require "util/utils.scm")
(require "util/match-assoc.scm")
(provide run interp)

;; utilities
;;

;;(define (print p) (display p) (newline))

;(define-syntax mapply
;  (syntax-rules ()
;    ((mapply f xs arg ...)
;     (map (lambda (x) (f x arg ...)) xs))))

(define-syntax push!
  (syntax-rules ()
    ((push! <obj> <stack>)
     (set! <stack> (cons <obj> <stack>)))))

(define-syntax pop!
  (syntax-rules ()
    ((pop! <obj> <stack>)
     (let ((top (car <stack>)))
       (set! <stack> (cdr <stack>))
       top))))

(struct label
  (address))

(struct closure
  (env
   label))

;; program

(struct program
  (globals
   (stack #:mutable)
   code
   (instruction-pointer #:mutable)
   (return-register #:mutable)
   (env-register #:mutable)))

(define (set-return-register! p v)
  (set-program-return-register! p v))

(define (set-env-register! p v)
  (set-program-env-register! p v))

(define (set-ip! p ip)
  (set-program-instruction-pointer! p ip))

(define (ip++ p)
  (set-ip! p (+ (program-instruction-pointer p) 1)))

(define (get-instruction p)
  (vector-ref (program-code p) (program-instruction-pointer p)))

(define (stack-push! p v)
  (set-program-stack! p (cons (box v) (program-stack p))))

(define (stack-pop! p)
  (let ((stack (program-stack p)))
    (if (null? stack)
        (error 'stack-pop! "tried to pop! from empty stack")
        (let ((top (car stack)))
          (set-program-stack! p (cdr stack))
          (unbox top)))))

(define (stack-subtract p n)
  (if (= 0 n)
      #t
      (begin (stack-pop! p)
             (stack-subtract p (- n 1)))))

(define (stack-ref p n)
  (define (stack-ref* s n)
    (if (null? s)
        (error 'stack-ref "stack to small for reference")
        (if (= 0 n)
            (unbox (car s))
            (stack-ref* (cdr s) (- n 1)))))
  (stack-ref* (program-stack p) n))

(define (stack-set! p n v)
  (define (stack-set!* s n v)
    (if (null? s)
        (error 'stack-set! "stack to small for reference")
        (if (= 0 n)
            (set-box! (car s) v)
            (stack-set!* (cdr s) (- n 1) v))))
  (stack-set!* (program-stack p) n v))

(define (drop ls n)
  (if (= n 0)
      ls
      (drop (cdr ls) (- n 1))))

(define (stack-fold p width distance)
  (let ((stack (program-stack p)))
    (let loop ((top '()) (width width) (stack stack))
      (if (= 0 width)
	  (set-program-stack! p
			      (append (reverse top)
				      (drop stack distance)))
	  (loop (cons (car stack) top)
		(- width 1)
		(cdr stack))))))

;; stack operations
;;


;; interpreter
;;

(define builtins `((display . ,display)
                   (newline . ,newline)
                   (print . ,print)
                   (+ . ,+)
                   (- . ,-)
                   (* . ,*)
                   (/ . ,quotient)
                   (modulo . ,modulo)
                   (list . ,list)
                   (cons . ,cons)
                   (car . ,car)
                   (cdr . ,cdr)
                   (null? . ,null?)
                   (pair? . ,pair?)
		   (number? . ,number?)
		   (symbol? . ,symbol?)
                   (= . ,=)
                   (< . ,<)
                   (> . ,>)
                   (>= . ,>=)
                   (<= . ,<=)
                   (eq? . ,eq?)

                   (make-vector . ,make-vector)
		   (vector-length . ,vector-length)
		   (vector-ref . ,vector-ref)
		   (vector-set! . ,vector-set!)
                   (string-length . ,string-length)
                   (string-ref . ,string-ref)
		   (list->vector . ,list->vector)
		   (string->list . ,string->list)
                   (list->string . ,list->string)
		   (char->integer . ,char->integer)
		   (integer->char . ,integer->char)
                   (symbol->list . ,(lambda (s) (string->list (symbol->string s))))))

(define (apply-builtin f args)
  (cond ((assoc f builtins)
         => (lambda (entry)
              (apply (cdr entry) args)))
        (else (error 'apply-builtin "no such builtin" f))))

(define (execute-program p)
  (if (execute-instruction (get-instruction p) p)
      (execute-program p)
      (print 'terminated)))

(define (execute-instruction inst p)
  (match inst
    (`(builtin ,f . ,args)
     (set-return-register! p (apply-builtin f (mapply evaluate-exp args p)))
     (ip++ p)
     #t)
    (`(jump ,ip)
     (set-ip! p ip)
     #t)
    (`(branch ,test ,fail-label)
     (if (evaluate-exp test p)
         (ip++ p)
         (set-ip! p fail-label))
     #t)
    (`(return)
     (set-env-register! p (stack-pop! p))
     (set-ip! p (label-address (stack-pop! p)))
     #t)
    (`(push! ,v)
     (stack-push! p (evaluate-exp v p))
     (ip++ p)
     #t)
    (`(pop)
     (set-return-register! p (stack-pop! p))
     (ip++ p)
     #t)
    (`(extend-stack ,n)
     (let loop ((n n))
       (when (> n 0)
         (stack-push! p #f)
         (loop (- n 1))))
     (ip++ p)
     #t)
    (`(shrink-stack ,n)
     (let loop ((n n))
       (when (> n 0)
         (stack-pop! p)
         (loop (- n 1))))
     (ip++ p)
     #t)
    (`(stack-fold ,w ,d)
     (stack-fold p w d)
     (ip++ p)
     #t)
    (`(closure-set! ,c ,n ,v)
     (let ((v (evaluate-exp v p))
           (c (evaluate-exp c p)))
       (vector-set! (closure-env c) n v))
     (ip++ p)
     #t)
    (`(move! ,to ,from)
     (let ((v (evaluate-exp from p)))
       (match to
         (`(return-register) (set-return-register! p v))
         (`(env-register) (set-env-register! p v))
         (`(variable stk ,i) (stack-set! p i v))
         (`(variable env ,i) (vector-set! (program-env-register p) i v))
         (`(variable glo ,i) (vector-set! (program-globals p) i v))
         (else (error 'execute-instruction "not a place" to))))
     (ip++ p)
     #t)
    (`(call)
     (let ((f (program-return-register p)))
       (unless (closure? f)
	 (error 'execute-instruction "trying to call a non-closure" f))
       (set-env-register! p (closure-env f))
       (set-ip! p (label-address (closure-label f)))))
    (`(exit)
     #f)
    (else (error 'execute-instructon "?" inst))))

(define (evaluate-exp e p)
  (match e
    (`(atomic ,x) x)
    (`(quote ,x) x)
    (`(label ,x) (label x))
    (`(builtin ,f . ,args)
     (apply-builtin f (mapply evaluate-exp args p)))
    (`(closure ,size (label ,label))
     (closure (make-vector size) (label label)))
    (`(return-register) (program-return-register p))
    (`(env-register) (program-env-register p))
    (`(variable glo ,i) (vector-ref (program-globals p) i))
    (`(variable env ,i) (vector-ref (program-env-register p) i))
    (`(variable stk ,i) (stack-ref p i))
    (else (error 'evaluate-exp "?" e))))

(define (interp p)
  (match-assoc p (entry-point globals-size code)
    (execute-program
     (program (make-vector (car globals-size))
                   (list)
                   (list->vector code)
                   (car entry-point)
                   #f
                   #f))))

(define (read-program)
  (let loop ()
    (let ((object (read)))
      (if (eof-object? object)
          '()
          (cons object (loop))))))

(define (run)
  (interp (read-program)))
